Expression

• https://adv-r.hadley.nz/expressions.html
• Expression: separate out description of the action from the action itself.
• rlang::expr() function captures the structure of the code without evaluating it.

z <- rlang::expr(y <- x * 10)
z

y <- x * 10

x <- 4
base::eval(z)
y

[1] 40

Abstract Syntax trees (ASTs)

• The leaves of the trees are either symbols or constants.
• Strings and symbols are easily confused, so strings are always surrounded in quotes.
• The branches of the tree are called objects which represent function calls. The first child is the function that gets called, and the second and subsequent are children that are the arguments to that function.
• The depth within the tree is determined by the nesting of function calls. This also determines evaluation order, as evaluation proceeds from deepest-to-shallowest, but not guaranteed because of lazy evaluation.
• infix vs prefix calls:

library(rlang)
library(lobstr)

lobstr::ast(f(x, "y", 1))

█─f ├─x ├─“y” └─1

lobstr::ast(f(g(1, 2), h(3, 4, i())))

█─f ├─█─g │ ├─1 │ └─2 └─█─h ├─3 ├─4 └─█─i

Missing arguments to a function

• missing() function inside a function can check if an argument’s value comes from the user or from a default

fx <- function(x = 10, y = NULL) {
  list(missing(x), is.null(x), x, missing(y), is.null(y), y)
}

str(fx())

List of 6 $ : logi TRUE $ : logi FALSE $ : num 10 $ : logi TRUE $ : logi TRUE $ : NULL

str(fx(5))

List of 6 $ : logi FALSE $ : logi FALSE $ : num 5 $ : logi TRUE $ : logi TRUE $ : NULL

str(fx(5, 6))

List of 6 $ : logi FALSE $ : logi FALSE $ : num 5 $ : logi FALSE $ : logi FALSE $ : num 6

args(fx)

function (x = 10, y = NULL) NULL

lapply(list(1, NULL, 2, NULL), function(x = NULL) is.null(x))

[[1]] [1] FALSE

[[2]] [1] TRUE

[[3]] [1] FALSE

[[4]] [1] TRUE

sapply(list(1, NULL, 2, NULL), function(x = NULL) is.null(x))

[1] FALSE TRUE FALSE TRUE

sapply(list(1, NULL, 2, NULL), function(x) missing(x))

[1] FALSE FALSE FALSE FALSE

Capture the current call

• sys.call() captures exactly what the user feeds the function (some of them positional)
• match.call() captures named arguments

f <- function(a = 1, b = 2, c = 3){
  list(sys = sys.call(), match = match.call())
}

f(a = 5, 6)

$sys f(a = 5, 6)

$match f(a = 5, b = 6)

f <- function(a = 1, b = 2, c =3){
  print(match.call())
  print(as.list(match.call()))
  s <- do.call("sum", as.list(match.call())[-1L])
  print(s)
}

f(1, 2, 3)

f(a = 1, b = 2, c = 3) [[1]] f

$a [1] 1

$b [1] 2

$c [1] 3

[1] 6

fx <- function(a = 1, b = 2, c = 3, ...){
  all_arguments <- c(as.list(environment()), list(...))
  print("All arguments including default arguments:")
  print(all_arguments)
  print("----------------")
  print("match.call(): ")
  print(match.call())
  print("")
  print("----------------")
  print("match.call() as list:")
  print(as.list(match.call()))
  print("")
  print("----------------")
  print("match.call(expand.dots = TRUE) as list:")
  print(as.list(match.call(expand.dots = TRUE)))
  print("")
  print("----------------")
  print("list(...):")
  print(list(...))
  print("----------------")
  s <- do.call("sum", as.list(match.call())[-1L])
  print(s)
}

value <- 33
fx(a = value, d = 4, f = 5)

[1] “All arguments including default arguments:” $a [1] 33

$b [1] 2

$c [1] 3

$d [1] 4

$f [1] 5

[1] “—————-” [1] “match.call():” fx(a = value, d = 4, f = 5) [1] "" [1] “—————-” [1] “match.call() as list:” [[1]] fx

$a value

$d [1] 4

$f [1] 5

[1] "" [1] “—————-” [1] “match.call(expand.dots = TRUE) as list:” [[1]] fx

$a value

$d [1] 4

$f [1] 5

[1] "" [1] “—————-” [1] “list(…):” $d [1] 4

$f [1] 5

[1] “—————-” [1] 42

call() and do.call()

• call() returns a call object with its name and arguments
• do.call() evaluates the call immediately

call("sum", list(1, 2))

sum(list(1, 2))

base::eval(call("sum", c(1, 2)))

[1] 3

do.call("sum", list(1, 2))

[1] 3

R6 Object

library(Wu)
library(R6)
library(sloop)
library(epitools)

dt <- data.table(
  outcome = sample(c(0,1), 100, replace = TRUE)
, treatment = factor(rep(c("case", "control"), 50), levels = c("case", "control"))
, sex = factor(sample(c("F", "M"), 100, replace = TRUE), levels = c("F", "M"))
)


RR <- R6Class(
  "RR"
, list(binary = NA
     , groups = NA
     , data = NULL
     , groups_nlevels = NULL
     , tables = NULL
     , freqs = NULL
     , ors_str = NULL
     , oddsratios = NULL
     , riskratios = NULL
     , fx_or = function(x) epitools::epitab(x, method = "oddsratio", oddsratio = "wald")
     , fx_rr = function(x) epitools::epitab(x, method = "riskratio", oddsratio = "wald")
     , initialize = function(binary, groups, data) {
       self$binary <- binary
       self$groups <- groups
       vars <- c(binary, groups)
       self$data <- data[, ..vars]
       self$groups_nlevels <- lapply(groups, function(x) length(levels(self$data[[x]])))
       self$tables <- lapply(self$groups, function(x) table(self$data[[x]], self$data[[self$binary]]))
       self$freqs <- lapply(self$groups, function(x) Wu::tab_freq(self$binary, x, self$data))
       self$ors_str <- Wu::get_ors(self$binary, self$groups, self$data)
       self$oddsratios <- lapply(self$tables, self$fx_or)
       self$riskratios <- lapply(self$tables, self$fx_rr)
     }
     ))



RR1 <- RR$new(binary = "outcome", groups = c("treatment", "sex"), data = dt)




add_copy_icon <- function(id){
  txt <- paste0('<button type=\"button\" onclick=\"selectElementContents( document.getElementById('
              , '\''
              , id
              , '\''
              , ') );\">Copy Table</button>')
  cat(txt)
}

add_copy_icon("t1")

RR1$oddsratios[[2]]$tab %>%
   prt(table.attr="id=t1", caption = "Table of Odds Ratio")

library(DT)
dt <- RR1$oddsratios[[2]]$tab
dt <- as.data.frame(dt)
dt <- round(dt, 4)

datatable(dt
, extensions = 'Buttons'
, options = list(
    dom = 'Bfrtip'
  , buttons = c('copy', 'csv', 'excel', 'pdf', 'print')
  )
  , caption = "Odds Ratios"
)

Test GPU (doesn’t work)

• http://www.r-tutor.com/gpu-computing/clustering/distance-matrix
• https://github.com/cdeterman/gpuR/wiki/Build-Instructions-for-Linux

test.data <- function(dim, num, seed = 17){
  set.seed(seed)
  matrix(rnorm(dim * dim), nrow = num)
}

m <- test.data(1200, 45000)

system.time(dist(m))


# Dev RViennaCL
devtools::install_github("cdeterman/RViennaCL")

# Dev gpuR
devtools::install_github("cdeterman/gpuR")


A <- seq.int(from=0, to=999)
B <- seq.int(from=1000, to=1)
gpuA <- gpuVector(A)
gpuB <- gpuVector(B)

C <- A + B
gpuC <- gpuA + gpuB

all(C == gpuC)

Environment

sessionInfo()

R version 4.1.0 (2021-05-18) Platform: x86_64-pc-linux-gnu (64-bit) Running under: Ubuntu 20.04.2 LTS

Matrix products: default BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0 LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0

locale: [1] LC_CTYPE=C.UTF-8 LC_NUMERIC=C LC_TIME=C.UTF-8
[4] LC_COLLATE=C.UTF-8 LC_MONETARY=C.UTF-8 LC_MESSAGES=C.UTF-8
[7] LC_PAPER=C.UTF-8 LC_NAME=C LC_ADDRESS=C
[10] LC_TELEPHONE=C LC_MEASUREMENT=C.UTF-8 LC_IDENTIFICATION=C

attached base packages: [1] stats graphics grDevices utils datasets methods base

other attached packages: [1] epitools_0.5-10.1 sloop_1.0.1 R6_2.5.0
[4] Wu_0.0.0.9000 flexdashboard_0.5.2 lme4_1.1-27.1
[7] Matrix_1.3-4 mgcv_1.8-36 nlme_3.1-152
[10] png_0.1-7 scales_1.1.1 nnet_7.3-16
[13] labelled_2.8.0 kableExtra_1.3.4 plotly_4.9.4.1
[16] gridExtra_2.3 ggplot2_3.3.5 DT_0.18
[19] tableone_0.13.0 magrittr_2.0.1 lubridate_1.7.10
[22] dplyr_1.0.7 plyr_1.8.6 data.table_1.14.0
[25] rmdformats_1.0.2 knitr_1.33

loaded via a namespace (and not attached): [1] httr_1.4.2 sass_0.4.0 tidyr_1.1.3 jsonlite_1.7.2
[5] viridisLite_0.4.0 splines_4.1.0 bslib_0.2.5.1 assertthat_0.2.1 [9] highr_0.9 yaml_2.2.1 pillar_1.6.1 lattice_0.20-44
[13] glue_1.4.2 digest_0.6.27 rvest_1.0.0 minqa_1.2.4
[17] colorspace_2.0-2 htmltools_0.5.1.1 survey_4.0 pkgconfig_2.0.3
[21] haven_2.4.1 bookdown_0.22 purrr_0.3.4 webshot_0.5.2
[25] svglite_2.0.0 tibble_3.1.2 generics_0.1.0 ellipsis_0.3.2
[29] withr_2.4.2 klippy_0.0.0.9500 lazyeval_0.2.2 survival_3.2-11
[33] crayon_1.4.1 evaluate_0.14 fansi_0.5.0 MASS_7.3-54
[37] forcats_0.5.1 xml2_1.3.2 tools_4.1.0 hms_1.1.0
[41] mitools_2.4 lifecycle_1.0.0 stringr_1.4.0 munsell_0.5.0
[45] compiler_4.1.0 jquerylib_0.1.4 systemfonts_1.0.2 rlang_0.4.11
[49] grid_4.1.0 nloptr_1.2.2.2 rstudioapi_0.13 htmlwidgets_1.5.3 [53] crosstalk_1.1.1 rmarkdown_2.9 boot_1.3-28 gtable_0.3.0
[57] DBI_1.1.1 performance_0.7.2 utf8_1.2.1 insight_0.14.2
[61] stringi_1.6.2 Rcpp_1.0.7 vctrs_0.3.8 tidyselect_1.1.1 [65] xfun_0.24